;; A text game engine

;; Define location nodes.
(defparameter *nodes* '((living-room (you are in the living room.
                                      a wizard is snoring loudly on the couch.))
                        (garden (you are in a beautiful garden.
                                 there is a well in front of you.))
                        (attic (you are in the attic.
                                there is a giant welding torch in the corner.))))

;; Describe a location. (assoc)
(defun describe-location (location nodes)
  (cadr (assoc location nodes)))

;; (describe-location 'living-room *nodes*)

;; Define paths.
(defparameter *edges* '((living-room (garden west door)
                         (attic upstairs ladder))
                        (garden (living-room east door))
                        (attic (living-room downstairs ladder))))

;; Describe a path. (Quasiquoting)
(defun describe-path (edge)
  `(there is a ,(caddr edge) going ,(cadr edge) from here.))

;; (describe-path '(attic upstairs ladder))

;; Describe all paths. (append) (mapcar)
(defun describe-paths (location edges)
  (apply #'append (mapcar #'describe-path (cdr (assoc location edges)))))

;; call-arguments-limit
;; (apply #'list 1 '(two 2) '(three (3) . 3) '(four (4) (4)))
;; (describe-paths 'living-room *edges*)

;; Define world objects.
(defparameter *objects* '(whiskey bucket chain frog))

;; Define object locations.
(defparameter *object-locations* '((whiskey living-room)
                                   (bucket living-room)
                                   (chain garden)
                                   (frog garden)))

;; Get alist of objects at loc
(defun object-at (loc objs obj-locs)
  (labels ((at-loc-p (obj)
             (eq (cadr (assoc obj obj-locs)) loc)))
    (remove-if-not #'at-loc-p objs)))

;; Describe objects at location.
(defun describe-objects (loc objs obj-loc)
  (labels ((describe-obj (obj)
             `(you see a ,obj on the floor.)))
    (apply #'append (mapcar #'describe-obj (object-at loc objs obj-loc)))))

(describe-objects 'garden *objects* *object-locations*)

;; Avatar current location.
(defparameter *location* 'living-room)

;; Avatar looks around.
(defun look ()
  (append (describe-location *location* *nodes*)
          (describe-paths *location* *edges*)
          (describe-objects *location* *objects* *object-locations*)))

;; Avatar walk to a direction.
(defun walk (direction)
  (let ((next (find direction (cdr (assoc *location* *edges*))
                    :key #'cadr)))
    (if next
        (progn
          (setf *location* (car next))
          (look))
        '(you can't go that way.))))

;; Pickup item
(defun pickup (obj)
  (cond ((member obj (object-at *location* *objects* *object-locations*))
         (push (list obj 'body) *object-locations*)
         `(you are now carrying the ,obj))
        (t
         '(you can't pickup that.))))

(defun inventory ()
  (cons 'items- (object-at 'body *objects* *object-locations*)))

;; Game repl.
(defun game-repl ()
  (let ((cmd (game-read)))
        (unless (eq (car cmd) 'quit)
          (game-print (game-eval cmd))
          (game-repl))))

;; Read a line 'a b c' and convert to (a 'b 'c) format.
(defun game-read ()
  (let ((cmd (read-from-string
              (concatenate 'string "(" (read-line) ")"))))
    (flet ((quote-it (x)
             (list 'quote x)))
      (cons (car cmd) (mapcar #'quote-it (cdr cmd))))))

(defparameter *allowed-commands* '(look walk pickup inventory))

;; Game eval.
(defun game-eval (sexp)
  (if (member (car sexp) *allowed-commands*)
      (eval sexp)
      '(i do not know that command.)))

(defun game-print (lst)
  (princ (coerce
          (tweak-text (coerce (string-trim "()" (prin1-to-string lst)) 'list)
                      t nil)
          'string))
  (fresh-line))

(defun tweak-text (lst caps lit)
  (when lst
    (let ((item (car lst)) (rest (cdr lst)))
          (cond ((eq item #\space)
                 ;; let space unchanged.
                 (cons item (tweak-text rest caps lit)))
                ((member item '(#\! #\? #\.))
                 ;; Upcase next sentence character.
                 (cons item (tweak-text rest t lit)))
                ((eq item #\")
                 (tweak-text rest caps (not lit)))
                (lit (cons item (tweak-text rest nil lit)))
                (caps
                 (cons (char-upcase item) (tweak-text rest nil lit)))
                (t (cons (char-downcase item) (tweak-text rest nil nil)))))))

      
 